home *** CD-ROM | disk | FTP | other *** search
- ;;; -*- Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; The data in this file contains enhancments. ;;;;;
- ;;; ;;;;;
- ;;; Copyright (c) 1984,1987 by William Schelter,University of Texas ;;;;;
- ;;; All rights reserved ;;;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;;
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- (in-package "MAXIMA")
- (macsyma-module pois3)
-
- ;; GENERAL POISSON SERIES
-
- (DECLARE-TOP (SPECIAL *ARGC *COEF POISVALS POISCO1 POISCOM1 B* A* *A SS CC H* POISHIFT
- POISTSM POISSIZ POISTS $WTLVL $POISZ $POIS1)
- (*LEXPR $PRINT $COEFF)
- (GENPREFIX \P))
-
- (DEFVAR TRIM NIL)
-
- (DEFUN FUMCHECK (X)
- (NOT (AND (ATOM X) (INTEGERP X) (LESSP (ABS X) POISTSM))))
-
- (DEFUN CHECKENCODE(R)
- (PROG(Q)
- (SETQ Q ($COEFF R '$U))
- (COND ((FUMCHECK Q) (RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$U Q)) NIL))))
- (SETQ Q ($COEFF R '$V))
- (COND ((FUMCHECK Q)(RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$V Q)) NIL))))
- (SETQ Q ($COEFF R '$W))
- (COND ((FUMCHECK Q)(RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$W Q)) NIL))))
- (SETQ Q ($COEFF R '$X))
- (COND ((FUMCHECK Q)(RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$X Q)) NIL))))
- (SETQ Q ($COEFF R '$Y))
- (COND ((FUMCHECK Q)(RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$Y Q)) NIL))))
- (SETQ Q ($COEFF R '$Z))
- (COND ((FUMCHECK Q)(RETURN NIL))
- (T (SETQ R (SIMPLIFYA (LIST '(MPLUS) R (LIST '(MTIMES) -1 '$Z Q)) NIL))))
- (COND ((EQUAL R 0)(RETURN T))
- (T (RETURN NIL)))))
-
- (DEFMFUN $POISSIMP (X)
- (IF (MBAGP X) (CONS (CAR X) (MAPCAR #'$POISSIMP (CDR X))) ($OUTOFPOIS X)))
-
- ;;;********
-
- (DECLARE-TOP(FIXNUM AE POISHIFT POISTSM POISSIZ POISTS))
- ;; ABOVE ASSUMES POISLIM(5) OR LESS ALSO REDEFINE ORDER< AND ORDER= TO BE < AND =
-
- ;;; THIS TELLS THE EVALUATOR TO KEEP OUT OF POISSON $SERIES.
-
- (DEFPROP MPOIS (LAMBDA (X) X) MFEXPR*)
-
- (DEFMFUN $POISPLUS (A B)
- (SETQ A (INTOPOIS A) B (INTOPOIS B))
- (LIST '(MPOIS SIMP) (POISMERGE22 (CADR A) (CADR B)) (POISMERGE22 (CADDR A) (CADDR B))))
-
-
-
- (DECLARE-TOP (SPECIAL *B *FN))
- (DEFMFUN $POISMAP (P SINFN COSFN)
- (PROG (*B *FN)
- (SETQ P (INTOPOIS P))
- (SETQ *FN (LIST SINFN))
- (RETURN (LIST (CAR P)
- (POISMAP (CADR P))
- (PROG2 (SETQ *FN (LIST COSFN)) (POISMAP (CADDR P)))))))
-
- (DEFUN POISMAP (Y)
- (COND ((NULL Y) NIL)
- (T (SETQ *B (MEVAL (LIST *FN (POISCDECODE (CADR Y)) (POISDECODEC (CAR Y)))))
- (TCONS3(CAR Y) (INTOPOISCO *B) (POISMAP (CDDR Y))))))
-
- (DEFUN POISMERGE22 (R S)
- (COND ((NULL R) S)
- ((NULL S) R)
- ((EQUAL (CAR R) (CAR S))
- (PROG (TT)
- (SETQ TT (POISCO+ (CADR R) (CADR S)))
- (RETURN (COND ((POISPZERO TT) (POISMERGE22 (CDDR R) (CDDR S)))
- (T (CONS (CAR S) (CONS TT (POISMERGE22 (CDDR R) (CDDR S)))))))))
- ((LESSP (CAR R) (CAR S)) (CONS (CAR R) (CONS (CADR R) (POISMERGE22 (CDDR R) S))))
- (T (CONS (CAR S) (CONS (CADR S) (POISMERGE22 (CDDR S) R))))))
-
- (DEFUN POISCOSINE (M)
- (SETQ M (POISENCODE M))
- (COND ((POISNEGPRED M) (SETQ M (POISCHANGESIGN M))))
- (LIST '(MPOIS SIMP) NIL (LIST M POISCO1)))
-
- (DEFUN POISSINE (M)
- (SETQ M (POISENCODE M))
- (COND ((POISNEGPRED M) (LIST '(MPOIS SIMP) (LIST (POISCHANGESIGN M) POISCOM1) NIL))
- (T (LIST '(MPOIS SIMP) (LIST M POISCO1) NIL))))
-
- (DEFMFUN $INTOPOIS (X) (PROG (*A) (RETURN (INTOPOIS X))))
-
- (DEFUN INTOPOIS (A)
- (COND ((ATOM A)
- (COND ((EQUAL A 0.) $POISZ) (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A))))))
- ((EQ (CAAR A) 'MPOIS) A)
- ((EQ (CAAR A) '%SIN) (POISSINE (CADR A)))
- ((EQ (CAAR A) '%COS) (POISCOSINE (CADR A)))
- ((AND (EQ (CAAR A) 'MEXPT) (NUMBERP (CADDR A)) (GREATERP (CADDR A) 0.))
- ($POISEXPT (INTOPOIS (CADR A)) (CADDR A)))
- ((EQ (CAAR A) 'MPLUS)
- (SETQ *A (INTOPOIS (CADR A)))
- (MAPC (FUNCTION (LAMBDA (Z) (SETQ *A ($POISPLUS *A (INTOPOIS Z))))) (CDDR A))
- *A)
- ((EQ (CAAR A) 'MTIMES)
- (SETQ *A (INTOPOIS (CADR A)))
- (MAPC (FUNCTION (LAMBDA (Z) (SETQ *A ($POISTIMES *A (INTOPOIS Z))))) (CDDR A))
- *A)
- ((EQ (CAAR A) 'MRAT) (INTOPOIS (RATDISREP A)))
- (T (LIST '(MPOIS SIMP) NIL (LIST POISHIFT (INTOPOISCO A))))))
-
- (DEFUN TCONS (R S) (COND ((POISPZERO (CAR S)) (CDR S)) (T (CONS R S))))
-
- (DEFUN POISNEGPRED ($N)
- (PROG ($R)
- $LOOP(COND ((EQUAL $N 0.) (RETURN NIL)) (T NIL))
- (SETQ $R (DIFFERENCE (REMAINDER $N POISTS) POISTSM))
- (COND ((GREATERP $R 0.) (RETURN NIL))
- ((GREATERP 0. $R) (RETURN T))
- (T (SETQ $N (QUOTIENT $N POISTS))))
- (GO $LOOP)))
-
- (DEFUN POISCHANGESIGN ($N) (DIFFERENCE (TIMES POISHIFT 2.) $N))
-
- (DECLARE-TOP (SPECIAL $U $V $W $X $Y $Z))
-
- (DEFUN POISENCODE (H*) ;
- (COND ((NOT (CHECKENCODE H*))
- (merror "Illegal arg to POISSIMP:~%~M" H*)))
- (APPLY #'(LAMBDA ($Z $Y $X $W $V $U)
- (DECLARE (SPECIAL $U $V $W $X $Y $Z))
- (SETQ H* (MEVAL H*))
- (COND ((NOT (INTEGERP H*)) (merror "Illegal trig arg to POISSON form")))
- (PLUS POISHIFT H*))
- POISVALS))
-
- (PROG (N)
- (SETQ N 5)
- (SETQ POISVALS NIL)
- (SETQ POISTS (EXPT 2. N))
- (DO ((J 0. (f1+ J)))( (> J 5.)) (SETQ POISVALS (CONS (EXPT POISTS J) POISVALS)))
- (SETQ POISSIZ N
- POISTSM (EXPT 2. (SUB1 N))
- POISHIFT (PROG (SUM)
- (SETQ SUM 0.)
- (DO ((I 0. (f1+ I)))( (> I 5.)) (SETQ SUM (PLUS SUM (TIMES POISTSM (EXPT POISTS I)))))
- (RETURN SUM))
- $POISZ '((MPOIS SIMP) NIL NIL)
- $POIS1 (LIST '(MPOIS SIMP) NIL (LIST POISHIFT 1.)))
- N)
-
- (DEFUN POISDECODEC (M)
- (PROG (ARG H)
- (SETQ H M)
- (SETQ ARG (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$U))
- (SETQ H (QUOTIENT H POISTS))
- (SETQ ARG
- (LIST '(MPLUS)
- ARG
- (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$V)))
- (SETQ H (QUOTIENT H POISTS))
- (SETQ ARG
- (LIST '(MPLUS)
- ARG
- (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$W)))
- (SETQ H (QUOTIENT H POISTS))
- (SETQ ARG
- (LIST '(MPLUS)
- ARG
- (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$X)))
- (SETQ H (QUOTIENT H POISTS))
- (SETQ ARG
- (LIST '(MPLUS)
- ARG
- (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$Y)))
- (SETQ H (QUOTIENT H POISTS))
- (SETQ ARG
- (LIST '(MPLUS)
- ARG
- (LIST '(MTIMES) (DIFFERENCE (REMAINDER H POISTS) POISTSM) '$Z)))
- (RETURN (SIMPLIFYA ARG NIL))))
-
-
- ;;; THIS PROGRAM MULTIPLIES A POISSON SERIES P BY A NON-SERIES, C,
- ;;; WHICH IS FREE OF SINES AND COSINES .
-
- (DEFMFUN $POISCTIMES (C P)
- (LIST '(MPOIS SIMP) (POISCTIMES1 (SETQ C (INTOPOISCO C)) (CADR P)) (POISCTIMES1 C (CADDR P))))
-
-
-
- (DEFMFUN $OUTOFPOIS (P)
- (PROG (ANS)
- (COND ((OR (ATOM P) (NOT (EQ (CAAR P) 'MPOIS))) (SETQ P (INTOPOIS P))))
-
- ;; DO SINES
- (DO ((M
- (CADR P)
- (CDDR M)))(
- (NULL M))
- (SETQ ANS (CONS (LIST '(MTIMES)
- (POISCDECODE (CADR M))
- (LIST '(%SIN) (POISDECODEC (CAR M))))
- ANS)))
-
- ;; DO COSINES
- (DO ((M
- (CADDR P)
- (CDDR M)))(
- (NULL M))
- (SETQ ANS (CONS (LIST '(MTIMES)
- (POISCDECODE (CADR M))
- (COND ((EQUAL (CAR M) POISHIFT) 1.)
- (T (LIST '(%COS) (POISDECODEC (CAR M))))))
- ANS)))
- (RETURN (COND ((NULL ANS) 0.) (T (SIMPLIFYA (CONS '(MPLUS) ANS) NIL))))))
-
- (DEFMFUN $PRINTPOIS (P)
- (PROG NIL
- (SETQ P (INTOPOIS P))
-
- ;; DO SINES
- (DO ((M
- (CADR P)
- (CDDR M)))(
- (NULL M))
- (DISPLA (SIMPLIFYA (LIST '(MTIMES)
- (POISCDECODE (CADR M))
- (LIST '(%SIN) (POISDECODEC (CAR M))))
- T))
- (TERPRI))
-
- ;; DO COSINES
- (DO ((M
- (CADDR P)
- (CDDR M)))(
- (NULL M))
- (DISPLA (SIMPLIFYA (LIST '(MTIMES)
- (POISCDECODE (CADR M))
- (COND ((EQUAL (CAR M) POISHIFT) 1.)
- (T (LIST '(%COS) (POISDECODEC (CAR M))))))
- T))
- (TERPRI))
- (RETURN '$DONE)))
-
-
- ;;; $POISDIFF DIFFERENTIATES A POISSON SERIES WRT X, Y, Z, U, V, W, OR A COEFF VAR.
-
-
- (DEFMFUN $POISDIFF (P M)
- (DECLARE (SPECIAL M))
- (COND ((MEMQ M '($U $V $W $X $Y $Z))
- (LIST (CAR P) (COSDIF (CADDR P) M) (SINDIF (CADR P) M)))
- (T (LIST (CAR P)(POISDIF4(CADR P))(POISDIF4 (CADDR P))))))
-
-
- (DEFUN POISDIF4 (Y)
- (DECLARE (SPECIAL M))
- (COND ((NULL Y) NIL)
- (T (TCONS3 (CAR Y)(POISCODIF (CADR Y) M) (POISDIF4 (CDDR Y))))))
-
-
-
-
- ;;; COSDIF DIFFERENTIATES COSINES TO GET SINES
-
- (DEFUN COSDIF (H M)
- (COND ((NULL H) NIL)
- (T (TCONS (CAR H)
- (CONS (POISCO* (INTOPOISCO (MINUS (POISXCOEF (CAR H) M))) (CADR H))
- (COSDIF (CDDR H) M))))))
-
- (DEFUN SINDIF (H M)
- (COND ((NULL H) NIL)
- (T (TCONS (CAR H)
- (CONS (POISCO* (INTOPOISCO (POISXCOEF (CAR H) M)) (CADR H)) (SINDIF (CDDR H) M))))))
-
- (DEFUN POISXCOEF (H M)
- (DIFFERENCE (REMAINDER (QUOTIENT H
- (EXPT POISTS
- (CADR (MEMQ M '($U 0. $V 1. $W 2. $X 3. $Y 4. $Z 5.)))))
- POISTS)
- POISTSM))
-
-
-
-
- ;;; AVL BALANCED TREE SEARCH AND INSERTION.
- ;;; NODE LOOKS LIKE (KEY (LLINK . RLKINK) BALANCEFACTOR . RECORD)
- ;;; PROGRAM FOLLOWS ALGORITHM GIVEN IN KNUTH VOL. 3 455-57
-
- (DECLARE-TOP (SPECIAL ANS))
-
-
- ;; MACROS TO EXTRACT FIELDS FROM NODE
-
- (defMACRO KEY (&rest L) (CONS 'CAR L))
-
- (defMACRO LLINK (&rest L) (CONS 'CAADR L))
-
- (defMACRO RLINK (&rest L) (CONS 'CDADR L))
-
- (defMACRO BP (&rest L) (CONS 'CADDR L))
-
- (defMACRO REC (&rest L) (CONS 'CDDDR L))
-
-
- ;; FOR ORDERING KEYS
-
- (defMACRO ORDER< (&rest L) (CONS '< L))
- (defMACRO ORDER= (&rest L) (CONS '= L))
-
- ;; MACROS TO SET FIELDS IN NODE
-
- (defMACRO SETRLINK (&rest L) (setq l (cons nil l))
- (LIST 'RPLACD (LIST 'CADR (CADR L)) (CADDR L)))
-
- (defMACRO SETLLINK (&rest L) (setq l (cons nil l))
- (LIST 'RPLACA (LIST 'CADR (CADR L)) (CADDR L)))
-
- (defMACRO SETBP (&rest L) (setq l (cons nil l))
- (LIST 'RPLACA (LIST 'CDDR (CADR L)) (CADDR L)))
-
- (defMACRO SETREC (&rest L)(setq l (cons nil l))
- (LIST 'RPLACD (LIST 'CDDR (CADR L)) (CADDR L)))
-
-
- (DEFUN INSERT-IT (PP NEWREC) (SETREC PP (POISCO+ (REC PP) NEWREC)))
-
- (DEFUN AVLINSERT (K NEWREC HEAD)
- (PROG (QQ TT SS PP RR)
- (SETQ TT HEAD)
- (SETQ SS (SETQ PP (RLINK HEAD)))
- A2 (COND ((ORDER< K (KEY PP)) (GO A3))
- ((ORDER< (KEY PP) K) (GO A4))
- (T (INSERT-IT PP NEWREC) (RETURN HEAD)))
- A3 (SETQ QQ (LLINK PP))
- (COND ((NULL QQ) (SETLLINK PP (CONS K (CONS (CONS NIL NIL) (CONS 0. NEWREC)))) (GO A6))
- ((ORDER= 0. (BP QQ)) NIL)
- (T (SETQ TT PP SS QQ)))
- (SETQ PP QQ)
- (GO A2)
- A4 (SETQ QQ (RLINK PP))
- (COND ((NULL QQ) (SETRLINK PP (CONS K (CONS (CONS NIL NIL) (CONS 0. NEWREC)))) (GO A6))
- ((ORDER= 0. (BP QQ)) NIL)
- (T (SETQ TT PP SS QQ)))
- (SETQ PP QQ)
- (GO A2)
- A6 (COND ((ORDER< K (KEY SS)) (SETQ RR (SETQ PP (LLINK SS)))) (T (SETQ RR (SETQ PP (RLINK SS)))))
- A6LOOP
- (COND ((ORDER< K (KEY PP)) (SETBP PP -1.) (SETQ PP (LLINK PP)))
- ((ORDER< (KEY PP) K) (SETBP PP 1.) (SETQ PP (RLINK PP)))
- ((ORDER= K (KEY PP)) (GO A7)))
- (GO A6LOOP)
- A7 (COND ((ORDER< K (KEY SS)) (GO A7L)) (T (GO A7R)))
- A7L (COND ((ORDER= 0. (BP SS)) (SETBP SS -1.) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
- ((ORDER= (BP SS) 1.) (SETBP SS 0.) (RETURN HEAD)))
- (COND ((ORDER= (BP RR) -1.) NIL) (T (GO A9L)))
- (SETQ PP RR)
- (SETLLINK SS (RLINK RR))
- (SETRLINK RR SS)
- (SETBP SS 0.)
- (SETBP RR 0.)
- (GO A10)
- A9L (SETQ PP (RLINK RR))
- (SETRLINK RR (LLINK PP))
- (SETLLINK PP RR)
- (SETLLINK SS (RLINK PP))
- (SETRLINK PP SS)
- (COND ((ORDER= (BP PP) -1.) (SETBP SS 1.) (SETBP RR 0.))
- ((ORDER= (BP PP) 0.) (SETBP SS 0.) (SETBP RR 0.))
- ((ORDER= (BP PP) 1.) (SETBP SS 0.) (SETBP RR -1.)))
- (SETBP PP 0.)
- (GO A10)
- A7R (COND ((ORDER= 0. (BP SS)) (SETBP SS 1.) (SETLLINK HEAD (f1+ (LLINK HEAD))) (RETURN HEAD))
- ((ORDER= (BP SS) -1.) (SETBP SS 0.) (RETURN HEAD)))
- (COND ((ORDER= (BP RR) 1.) NIL) (T (GO A9R)))
- (SETQ PP RR)
- (SETRLINK SS (LLINK RR))
- (SETLLINK RR SS)
- (SETBP SS 0.)
- (SETBP RR 0.)
- (GO A10)
- A9R (SETQ PP (LLINK RR))
- (SETLLINK RR (RLINK PP))
- (SETRLINK PP RR)
- (SETRLINK SS (LLINK PP))
- (SETLLINK PP SS)
- (COND ((ORDER= (BP PP) 1.) (SETBP SS -1.) (SETBP RR 0.))
- ((ORDER= (BP PP) 0.) (SETBP SS 0.) (SETBP RR 0.))
- ((ORDER= (BP PP) -1.) (SETBP SS 0.) (SETBP RR 1.)))
- (SETBP PP 0.)
- A10 (COND ((EQ SS (RLINK TT)) (SETRLINK TT PP)) (T (SETLLINK TT PP)))
- (RETURN HEAD)))
-
- (DEFUN AVLINIT (KEY REC)
- (CONS 'TOP (CONS (CONS 0. (CONS KEY (CONS (CONS NIL NIL) (CONS 0. REC)))) (CONS 0. NIL))))
-
-
- ;; UNTREE CONVERTS THE TREE TO A LIST WHICH LOOKS LIKE ( SmALLEST-KEY RECORD NEXT-SMALLEST-KEY RECORD .... LARGEST-KEY
- ;;RECORD)
-
- (DEFUN UNTREE (H) (PROG (ANS) (UNTREE1 (RLINK H)) (RETURN ANS)))
-
- (DEFUN UNTREE1 (H)
- (COND ((NULL H) ANS)
- ((NULL (RLINK H)) (SETQ ANS (TCONS3 (KEY H) (REC H) ANS)) (UNTREE1 (LLINK H)))
- (T (SETQ ANS (TCONS3 (KEY H) (REC H) (UNTREE1 (RLINK H)))) (UNTREE1 (LLINK H)))))
-
- (DEFUN TCONS3 (R S TT) (COND ((POISPZERO S) TT) (T (CONS R (CONS S TT)))))
-
-
- (DEFUN POISMERGES (A AE L)
- (COND ((EQUAL POISHIFT AE) L) ; SINE(0) IS 0
- ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A) (POISCHANGESIGN AE) L))
- (T (POISMERGE A AE L))))
-
- (DEFUN POISMERGEC (A AE L)
- (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L)) (T (POISMERGE A AE L))))
-
- (DEFUN POISMERGE (A AE L) (COND ((POISPZERO A) NIL) (T (MERGE11 A AE L))))
-
- (DEFUN POISMERGE2 (R S)
- (COND ((NULL R) S)
- ((NULL S) R)
- (T (PROG (M N TT)
- (SETQ M (SETQ N (CONS 0. R)))
- A (COND ((NULL R) (RPLACD M S) (RETURN (CDR N)))
- ((NULL S) (RETURN (CDR N)))
- ((EQUAL (CAR R) (CAR S))
- (SETQ TT (POISCO+ (CADR R) (CADR S)))
- (COND ((POISPZERO TT) (RPLACD M (CDDR R)) (SETQ R (CDDR R) S (CDDR S)))
- (T (RPLACA (CDR R) TT) (SETQ S (CDDR S) R (CDDR R) M (CDDR M)))))
- ((GREATERP (CAR R) (CAR S))
- (RPLACD M S)
- (SETQ S (CDDR S))
- (RPLACD (CDDR M) R)
- (SETQ M (CDDR M)))
- (T (SETQ R (CDDR R)) (SETQ M (CDDR M))))
- (GO A)))))
-
- (DEFUN MERGE11 (A AE L) (POISMERGE2 (LIST AE A) L))
-
- (DEFUN POISMERGESX (A AE L)
- (COND ((EQUAL POISHIFT AE) L) ; SINE(0) IS 0
- ((POISNEGPRED AE) (AVLINSERT (POISCHANGESIGN AE) (POISCO* POISCOM1 A) L))
- (T (AVLINSERT AE A L))))
-
- (DEFUN POISMERGECX (A AE L)
- (COND ((POISNEGPRED AE) (AVLINSERT (POISCHANGESIGN AE) A L)) (T (AVLINSERT AE A L))))
-
-
-
-
- (DECLARE-TOP (SPECIAL TRIM POISCOM1 POISHIFT))
-
- (DEFUN POISCTIMES1 (C H)
- (COND ((NULL H) NIL)
- ((AND TRIM (TRIMF (CAR H))) (POISCTIMES1 C (CDDR H)))
- (T (TCONS (CAR H) (CONS (POISCO* C (CADR H)) (POISCTIMES1 C (CDDR H)))))))
-
- (DEFUN TRIMF (M)
- (MEVAL (LIST '($POISTRIM)
- (POISXCOEF M '$U)
- (POISXCOEF M '$V)
- (POISXCOEF M '$W)
- (POISXCOEF M '$X)
- (POISXCOEF M '$Y)
- (POISXCOEF M '$Z))))
-
- (DEFMFUN $POISTIMES (A B)
- (PROG (SLC CLC TEMP AE AA ZERO TRIM T1 T2 F1 F2)
- (SETQ A (INTOPOIS A) B (INTOPOIS B))
- (COND ((OR (GETL-FUN '$POISTRIM '(EXPR SUBR))
- (MGET '$POISTRIM 'MEXPR))
- (SETQ TRIM T)))
- (COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
- ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
- (SETQ SLC (AVLINIT POISHIFT (SETQ ZERO (INTOPOISCO 0.))) CLC (AVLINIT POISHIFT ZERO))
- ;; PROCEED THROUGH ALL THE SINES IN ARGUMENT A
- (DO ((SLA
- (CADR A)
- (CDDR SLA)))(
- (NULL SLA))
- (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
- ;; SINE(U)*SINE(V) ==> (-COSINE(U+V) + COSINE(U-V))/2
- (DO ((SLB
- (CADR B)
- (CDDR SLB)))(
- (NULL SLB))
- (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB))) T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
- (cond(trim(setq f1(trimf t1) f2 (trimf t2)))
- (t (setq f1 nil f2 nil)))
- (SETQ TEMP (POISCO* AA (CADR SLB)))
- (COND ((POISPZERO TEMP) NIL)
- (T (OR F1 (POISMERGECX TEMP T1 CLC))
- (OR F2 (POISMERGECX (POISCO* POISCOM1 TEMP) T2 CLC)))))
- ;; SINE*COSINE ==> SINE + SINE
- (DO ((CLB
- (CADDR B)
- (CDDR CLB)))(
- (NULL CLB))
- (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))) T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))
- (cond(trim(setq f1(trimf t1) f2 (trimf t2)))
- (t (setq f1 nil f2 nil)))
- (SETQ TEMP (POISCO* AA (CADR CLB)))
- (COND ((POISPZERO TEMP) NIL)
- (T (OR F1 (POISMERGESX TEMP T1 SLC)) (OR F2 (POISMERGESX TEMP T2 SLC))))))
- ;; PROCEED THROUGH ALL THE COSINES IN ARGUMENT A
- (DO ((CLA
- (CADDR A)
- (CDDR CLA)))(
- (NULL CLA))
- (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
- ;; COSINE*SINE ==> SINE - SINE
- (DO ((SLB
- (CADR B)
- (CDDR SLB)))(
- (NULL SLB))
- (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB))) T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))(cond(trim(setq f1(trimf t1) f2 (trimf t2)))
- (t (setq f1 nil f2 nil))
- )
- (COND
- (T (SETQ TEMP (POISCO* AA (CADR SLB)))
- (COND ((POISPZERO TEMP) NIL)
- (T (OR F1 (POISMERGESX (POISCO* POISCOM1 TEMP) T1 SLC))
- (OR F2 (POISMERGESX TEMP T2 SLC)))))))
- ;; COSINE*COSINE ==> COSINE + COSINE
- (DO ((CLB
- (CADDR B)
- (CDDR CLB)))(
- (NULL CLB))
- (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))) T2 (PLUS AE (MINUS POISHIFT) (CAR CLB)))(cond(trim(setq f1(trimf t1) f2 (trimf t2)))
- (t (setq f1 nil f2 nil))
- )
- (COND
- (T (SETQ TEMP (POISCO* AA (CADR CLB)))
- (COND ((POISPZERO TEMP) NIL)
- (T (OR F1 (POISMERGECX TEMP T1 CLC))
- (OR F2 (POISMERGECX TEMP T2 CLC))))))))
- (RETURN (LIST '(MPOIS SIMP) (UNTREE SLC) (UNTREE CLC)))))
-
- (DEFMFUN $POISEXPT (P N)
- (PROG (U H)
- (COND ((ODDP N) (SETQ U P)) (T (SETQ U (SETQ H (INTOPOIS 1.)))))
- A (SETQ N (LSH N -1.))
- (COND ((ZEROP N) (RETURN U)))
- (setq p ($POISTIMES P P))
- (COND ((ODDP N) (SETQ U (COND ((EQUAL U H) P) (T ($POISTIMES U P))))))
- (GO A)))
-
- (DEFMFUN $POISSQUARE (A) ($POISEXPT A 2))
-
-
- ;;; $POISINT INTEGRATES A POISSON SERIES WRT X,Y, Z, U, V, W. THE VARIABLE OF
- ;;; INTEGRATION MUST OCCUR ONLY IN THE ARGUMENTS OF SIN OR COS,
- ;;; OR ONLY IN THE COEFFICIENTS. POISCOINTEG IS CALLED TO INTEGRATE COEFFS.
-
- ;;; NON-PERIODIC TERMS ARE REMOVED.
-
- (DEFMFUN $POISINT (P M)
- (DECLARE (SPECIAL M))
- (PROG (B*)
- (SETQ P (INTOPOIS P))
- (COND ((MEMQ M '($U $V $W $X $Y $Z))
- (RETURN (LIST (CAR P)
- (COSINT* (CADDR P) M)
- (SININT* (CADR P) M))))
- (T (RETURN (LIST (CAR P)
- (POISINT4 (CADR P))
- (POISINT4 (CADDR P))))))))
-
- (DEFUN POISINT4 (Y)
- (DECLARE (SPECIAL M))
- (COND ((NULL Y) NIL)
- (T (TCONS3 (CAR Y)(POISCOINTEG (CADR Y) M) (POISINT4 (CDDR Y))))))
-
- ;;;COSINT* INTEGRATES COSINES TO GET SINES
-
- (DEFUN COSINT* (H M)
- (COND ((NULL H) NIL)
- ((EQUAL 0. (SETQ B* (POISXCOEF (CAR H) M))) (COSINT* (CDDR H) M))
- (T (TCONS (CAR H)
- (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) B* -1.)) (CADR H))
- (COSINT* (CDDR H) M))))))
-
- (DEFUN SININT* (H M)
- (COND ((NULL H) NIL)
- ((EQUAL 0. (SETQ B* (POISXCOEF (CAR H) M))) (SININT* (CDDR H) M))
- (T (TCONS (CAR H)
- (CONS (POISCO* (INTOPOISCO (LIST '(MEXPT) (MINUS (POISXCOEF (CAR H) M)) -1.))
- (CADR H))
- (SININT* (CDDR H) M))))))
-
-
- ;;; $POISSUBST SUBSTITUTES AN EXPRESSION FOR A VARIABLE IN ARGUMENT OF TRIG FUNCTIONS OR
- ;;; COEFFICIENTS.
-
- (DEFUN POISSUBSTA (A B* C)
- (PROG (SS CC)
- (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1. B*)))
- POISHIFT))
- (POISSUBST1S (CADR C))
- (POISSUBST1C (CADDR C))
- (RETURN (LIST (CAR C) SS CC))))
-
- (DEFUN POISSUBST1S (C)
- (COND ((NULL C) NIL) (T (SETQ SS (POISMERGES (CADR C) (ARGSUBST (CAR C)) SS)) (POISSUBST1S (CDDR C)))))
-
- (DEFUN POISSUBST1C (C)
- (COND ((NULL C) NIL) (T (SETQ CC (POISMERGEC (CADR C) (ARGSUBST (CAR C)) CC)) (POISSUBST1C (CDDR C)))))
-
- (DEFUN ARGSUBST (C) (PLUS C (TIMES H* (POISXCOEF C B*))))
-
- (DEFMFUN $POISSUBST N
- (COND ((NOT (OR (EQUAL N 3.) (EQUAL N 5.))) (merror "WRONG NUMBER OF ARGS TO POISSUBST"))
- ((EQUAL N 5.)
- (FANCYPOISSUBST (ARG 1.) (ARG 2.) (INTOPOIS (ARG 3.)) (INTOPOIS (ARG 4.)) (ARG 5.)))
- (T ((LAMBDA (A* B* C) (COND ((MEMQ B* '($U $V $W $X $Y $Z)) (POISSUBSTA A* B* C))
- (T (LIST (CAR C) (POISSUBSTCO1 (CADR C)) (POISSUBSTCO1 (CADDR C))))))
- (ARG 1.)
- (ARG 2.)
- (INTOPOIS (ARG 3.))))))
-
-
-
- (DECLARE-TOP (unSPECIAL $U $V $W $X $Y $Z))
-
- (DEFUN POISSUBSTCO1 (C)
- (COND ((NULL C) NIL) (T (TCONS (CAR C) (CONS (POISSUBSTCO A* B* (CADR C)) (POISSUBSTCO1 (CDDR C)))))))
-
- (DECLARE-TOP (SPECIAL DC DS *ANS))
-
- (DEFUN FANCYPOISSUBST (A B* C D N)
-
- ;;SUBSTITUTES A+D FOR B IN C, WHERE D IS EXPANDED IN POWERSERIES TO ORDER N
- (PROG (H* DC DS *ANS)
- (SETQ *ANS (LIST '(MPOIS SIMP) NIL NIL) D (INTOPOIS D) DC (INTOPOIS 1.) DS (INTOPOIS 0.))
- (COND ((EQUAL N 0.) (RETURN ($POISSUBST A B* C))))
- (FANCYPOIS1S D 1. 1. N)
- (SETQ H* (DIFFERENCE (POISENCODE (LIST '(MPLUS) A (LIST '(MTIMES) -1. B*)))
- POISHIFT))
- (FANCYPAS (CADR C))
- (FANCYPAC (CADDR C))
- (RETURN *ANS)))
-
- (DEFUN FANCYPOIS1S (D DP N LIM) ; DP IS LAST POWER: D^(N-1), LIM IS HIGHEST TO
- (COND ((GREATERP N LIM) NIL) ;GO
- (T (SETQ DS ($POISPLUS DS
- ($POISCTIMES (LIST '(RAT)
- (EXPT -1. (QUOTIENT (SUB1 N) 2.))
- (FACTORIAL N))
- (SETQ DP ($POISTIMES DP D)))))
- (FANCYPOIS1C D DP (f1+ N) LIM))))
-
- (DEFUN FANCYPOIS1C (D DP N LIM) ; DP IS LAST POWER: D^(N-1), LIM IS HIGHEST TO
- (COND ((GREATERP N LIM) NIL) ;GO
- (T (SETQ DC
- ($POISPLUS DC
- ($POISCTIMES (LIST '(RAT) (EXPT -1. (QUOTIENT N 2.)) (FACTORIAL N))
- (SETQ DP ($POISTIMES DP D)))))
- (FANCYPOIS1S D DP (f1+ N) LIM))))
-
-
- ;;; COS(R+K*B) ==> K*COS(R+K*A)*DC - K*SIN(R+K*A)*DS
- ;;; SIN(R+K*B) ==> K*COS(R+K*A)*DS + K*SIN(R+K*A)*DC
-
- (DECLARE-TOP (SPECIAL *ARGC *COEF))
-
- (DEFUN FANCYPAC (C)
- (PROG NIL
- (COND ((NULL C) (RETURN NIL)))
- (SETQ *COEF (POISXCOEF (CAR C) B*))
- (COND ((EQUAL *COEF 0.)
- (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) NIL (LIST (CAR C) (CADR C)))))
- (GO END)))
- (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF)))) (GO END)))
- (SETQ *ARGC (ARGSUBST (CAR C)))
- (SETQ *ANS
- ($POISPLUS *ANS
- ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
- NIL
- (POISMERGEC *COEF *ARGC NIL))
- DC)
- ($POISTIMES (LIST '(MPOIS SIMP)
- (POISMERGES (POISCO* POISCOM1 *COEF) *ARGC NIL)
- NIL)
- DS))))
- END (FANCYPAC (CDDR C))))
-
- (DEFUN FANCYPAS (C)
- (PROG NIL
- (COND ((NULL C) (RETURN NIL)))
- (SETQ *COEF (POISXCOEF (CAR C) B*))
- (COND ((EQUAL *COEF 0.)
- (SETQ *ANS ($POISPLUS *ANS (LIST '(MPOIS SIMP) (LIST (CAR C) (CADR C)) NIL)))
- (GO END)))
- (COND ((POISPZERO (SETQ *COEF (POISCO* (CADR C) (INTOPOISCO *COEF)))) (GO END)))
- (SETQ *ARGC (ARGSUBST (CAR C)))
- (SETQ *ANS ($POISPLUS *ANS
- ($POISPLUS ($POISTIMES (LIST '(MPOIS SIMP)
- NIL
- (POISMERGEC *COEF *ARGC NIL))
- DS)
- ($POISTIMES (LIST '(MPOIS SIMP)
- (POISMERGES *COEF *ARGC NIL)
- NIL)
- DC))))
- END (FANCYPAS (CDDR C))))
-
- ;ARGUMENT DO NOT EXCEED 15 IN ABSOLUTE VALUE
-
-
- ;;; THESE ARE THE ONLY COEFFICIENT DEPENDENT ROUTINES. RATIONAL FORM IS
- ;;; DEFINED IN FILE RATPOI >.
-
- ;;; POISCDECODE DECODES A COEFFICIENT
-
- (DEFUN POISCDECODE (X) X)
-
-
- ;;; INTOPOISCO PUTS AN EXPRESSION INTO POISSON COEFFICIENT FORM
-
- (DEFUN INTOPOISCO (X) (SIMPLIFYA X NIL))
-
-
- ;;; POISCO+ ADDS 2 COEFFICIENTS
-
- (DEFUN POISCO+ (R S) (SIMPLIFYA (LIST '(MPLUS) R S) NIL))
-
-
- ;;; POISCO* MULTIPLIES 2 COEFFICIENTS
-
- (DEFUN POISCO* (R S) (SIMPLIFYA (LIST '(MTIMES) R S) NIL))
-
-
- ;;; HALVE DIVIDES A COEFFICIENT BY 2
-
- (DEFUN HALVE (R) (SIMPLIFYA (LIST '(MTIMES) '((RAT) 1. 2.) R) NIL))
-
-
- ;;; POISSUBSTCO SUBSTITUTES AN EXPRESSION FOR A VARIABLE IN A COEFFICIENT.
-
- (DEFUN POISSUBSTCO (A B C) (MAXIMA-SUBSTITUTE A B C))
-
- ;;; THIS DIFFERENTIATES A COEFFICIENT
-
- (DEFUN POISCODIF (H VAR)($DIFF H VAR))
-
- ;;; THIS INTEGRATES A COEFFICIENT
- (DEFUN POISCOINTEG (H VAR)(INTOPOISCO($INTEGRATE (POISCDECODE H) VAR)))
-
- ;;; TEST FOR ZERO
-
- (DEFUN POISPZERO (X) (ZEROP1 X))
-
-
- ;;; THE NUMBER 1 IN COEFFICIENT ARITHMETIC, THE NUMBER -1
-
- (SETQ POISCO1 1. POISCOM1 -1.)
-
-
-
-
- ;; THE FOLLOWING PROGRAMS FOLLOW THE SUGGESTIONS OF W.H.JEFFERYS, FOR
- ;; FASTER POISSON SERIES MULTIPLICATION THAN JUST STRAIGHT INSERTION.
- ;; THEY ARE NOT AS FAST AS THE AVL TREE INSERTION, HOWEVER. WE KEEP
- ;; THEM HERE FOR THE RECORD.
-
- ;(COMMENT(DECLARE (SPECIAL SLCX CLCX LASTPTR TRIM POISCOM1 POISHIFT CLC SLC CLCPTR SLCPTR))
-
- ;(DEFUN POISMERGE2K (S R)
- ; (COND ((NULL R)(SETQ LASTPTR S))
- ; ((NULL S) (SETQ LASTPTR R))
- ; (T (PROG (M N TT)
- ; (SETQ M (SETQ N (CONS 0. R)))
- ; A (COND ((NULL R) (RPLACD M S)(SETQ LASTPTR S) (RETURN (CDR N)))
- ; ((NULL S) (SETQ LASTPTR R) (RETURN (CDR N)))
- ; ((EQUAL (CAR R) (CAR S))
- ; (SETQ TT (POISCO+ (CADR R) (CADR S)))
- ; (COND ((POISPZERO TT) (RPLACD M (CDDR R)) (SETQ R (CDDR R) S
- ; (CDDR S)))
- ; (T (RPLACA (CDR R) TT) (SETQ S (CDDR S) R (CDDR R) M
- ; (CDDR M)))))
- ; ((GREATERP (CAR R) (CAR S))
- ; (RPLACD M S)
- ; (SETQ S (CDDR S))
- ; (RPLACD (CDDR M) R)
- ; (SETQ M (CDDR M)))
- ; (T (SETQ R (CDDR R)) (SETQ M (CDDR M))))
- ; (GO A)))))
-
- ;(DEFUN POISMERGESQ (A AE L)
- ; (SETQ SLCX (COND ((EQUAL POISHIFT AE) L) ; SINE(0) IS 0
- ; ((POISNEGPRED AE) (POISMERGE (POISCO* POISCOM1 A)
- ; (POISCHANGESIGN AE) L))
- ; (T (POISMERGE A AE L)))))
-
- ;(DEFUN POISMERGECQ (A AE L)
- ; (SETQ CLCX (COND ((POISNEGPRED AE) (POISMERGE A (POISCHANGESIGN AE) L))
- ; (T (POISMERGE A AE L)))))
-
- ;(DEFUN POISMERGESY (A AE L)
- ; (SETQ SLC (COND ((EQUAL POISHIFT AE) L) ; SINE(0) IS 0
- ; ((POISNEGPRED AE) (POISMERGESY1 (POISCO* POISCOM1 A)
- ; (POISCHANGESIGN AE) L))
- ; (T (POISMERGESY1 A AE L)))))
-
- ;(DEFUN POISMERGECY (A AE L)
- ; (SETQ CLC (COND ((POISNEGPRED AE) (POISMERGECY1 A (POISCHANGESIGN AE) L))
- ; (T (POISMERGECY1 A AE L)))))
-
- ;(DEFUN POISMERGECY1 (A AE L)
- ; (COND ((POISPZERO A) NIL)
- ; ((OR(NULL CLCPTR)(LESSP AE (CAR CLCPTR))) (SETQ CLC(POISMERGE2K(LIST AE A) L))
- ; (SETQ CLCPTR LASTPTR))
- ; (T (POISMERGE2K(LIST AE A) CLCPTR)
- ;(SETQ CLCPTR LASTPTR)))
- ; CLC)
-
- ;(DEFUN POISMERGESY1 (A AE L)
- ; (COND ((POISPZERO A) NIL)
- ; ((OR(NULL SLCPTR)(LESSP AE (CAR SLCPTR))) (SETQ SLC(POISMERGE2K(LIST AE A) L))(SETQ SLCPTR LASTPTR))
- ; (T (POISMERGE2K(LIST AE A) SLCPTR)
- ;(SETQ SLCPTR LASTPTR)))
- ; SLC )
-
- ;(DEFMFUN $POISTIMESL (A B)
- ; (PROG (SLC SLCPTR CLC CLCPTR TEMP AE AA TRIM T1 T2 F1 F2 LASTPTR SLCX CLCX)
- ; (SETQ A (INTOPOIS A) B (INTOPOIS B))
- ; (COND ((OR (GETL '$POISTRIM '(EXPR SUBR)) (MGET '$POISTRIM 'MEXPR))
- ; (SETQ TRIM T)))
- ; (COND ((NONPERIOD A) (RETURN ($POISCTIMES (CADR (CADDR A)) B)))
- ; ((NONPERIOD B) (RETURN ($POISCTIMES (CADR (CADDR B)) A))))
- ; ;; PROCEED THROUGH ALL THE SINES IN ARGUMENT A
- ; (SETQ SLCPTR SLC CLCPTR CLC CLCX NIL SLCX NIL)
- ; (DO SLA
- ; (CADR A)
- ; (CDDR SLA)
- ; (NULL SLA)
- ; (SETQ AA (HALVE (CADR SLA)) AE (CAR SLA))
- ; ;; SINE(U)*SINE(V) ==> (-COSINE(U+V) + COSINE(U-V))/2
- ; (DO SLB
- ; (CADR B)
- ; (CDDR SLB)
- ; (NULL SLB)
- ; (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB)))
- ; T2 (PLUS AE (MINUS POISHIFT) (CAR SLB)))
- ; (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2)))
- ; (SETQ F1 NIL F2 NIL))
- ; (T (SETQ TEMP (POISCO* AA (CADR SLB)))
- ; (COND ((POISPZERO TEMP) NIL)
- ; (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
- ; (OR F2 (POISMERGECY (POISCO* POISCOM1 TEMP) T2 CLC)))))))
- ; ;; SINE*COSINE ==> SINE + SINE
- ; (DO CLB
- ; (CADDR B)
- ; (CDDR CLB)
- ; (NULL CLB)
- ; (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))) T2
- ; (PLUS AE (MINUS POISHIFT) (CAR CLB)))
- ; (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2)))
- ; (SETQ F1 NIL F2 NIL))
- ; (T (SETQ TEMP (POISCO* AA (CADR CLB)))
- ; (COND ((POISPZERO TEMP) NIL)
- ; (T (OR F1 (POISMERGESQ TEMP T1 SLCX))
- ; (OR F2 (POISMERGESY TEMP T2 SLC))))))))
- ; (SETQ CLC(POISMERGE2 CLC CLCX)SLC (POISMERGE2 SLC SLCX))
-
- ; ;; PROCEED THROUGH ALL THE COSINES IN ARGUMENT A
- ; (SETQ SLCPTR SLC CLCPTR CLC SLCX NIL CLCX NIL)
- ; (DO CLA
- ; (CADDR A)
- ; (CDDR CLA)
- ; (NULL CLA)
- ; (SETQ AA (HALVE (CADR CLA)) AE (CAR CLA))
- ; ;; COSINE*SINE ==> SINE - SINE
- ; (DO SLB
- ; (CADR B)
- ; (CDDR SLB)
- ; (NULL SLB)
- ; (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR SLB))) T2
- ; (PLUS AE (MINUS POISHIFT) (CAR SLB)))
- ; (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2)))
- ; (SETQ F1 NIL F2 NIL))
- ; (T (SETQ TEMP (POISCO* AA (CADR SLB)))
- ; (COND ((POISPZERO TEMP) NIL)
- ; (T (OR F1 (POISMERGESQ (POISCO* POISCOM1 TEMP) T1 SLCX))
- ; (OR F2 (POISMERGESY TEMP T2 SLC)))))))
- ; ;; COSINE*COSINE ==> COSINE + COSINE
- ; (DO CLB
- ; (CADDR B)
- ; (CDDR CLB)
- ; (NULL CLB)
- ; (SETQ T1 (PLUS AE POISHIFT (MINUS (CAR CLB))) T2
- ; (PLUS AE (MINUS POISHIFT) (CAR CLB)))
- ; (COND ((AND TRIM (SETQ F1 (TRIMF T1)) (SETQ F2 (TRIMF T2)))
- ; (SETQ F1 NIL F2 NIL))
- ; (T (SETQ TEMP (POISCO* AA (CADR CLB)))
- ; (COND ((POISPZERO TEMP) NIL)
- ; (T (OR F1 (POISMERGECQ TEMP T1 CLCX))
- ; (OR F2 (POISMERGECY TEMP T2 CLC))))))))
- ; (SETQ CLC(POISMERGE2 CLC CLCX)SLC (POISMERGE2 SLC SLCX))
- ; (RETURN (LIST '(MPOIS SIMP) SLC CLC))))
- ;)
-
-
-